COMMENT ⊗   VALID 00004 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 -*- Syntax: Common-lisp Package: PZ Default-character-style: (:FIX :BOLD :NORMAL) -*-
C00005 00003	 Don't break up completed rows.  There is one exception - if the last completed row is
C00008 00004	 ACHIEVE-TWO-ROWS:    
C00012 ENDMK
C⊗;
;;; -*- Syntax: Common-lisp; Package: PZ; Default-character-style: (:FIX :BOLD :NORMAL) -*-

;;; These two macros both define the heuristics and record them on either *BETTER-MEASURES*
;;; or *WORSE-MEASURES*.


(defparameter *better-measures* nil)
(defparameter *worse-measures* nil)

(defmacro def-better-heuristic (name arglist &rest body)
  `(progn (pushnew ',name *better-measures*)
	  (defun ,name ,arglist ,@body)))

(defmacro def-worse-heuristic (name arglist &rest body)
  `(progn (pushnew ',name *worse-measures*)
	  (defun ,name ,arglist ,@body)))


;;; Calculate the MANHATTAN-DISTANCE of the next tile for the chain, both in the old board
;;; and the new.  If it has improved, and we haven't broken the existing chain, the new
;;; board is BETTER. 
  
(def-better-heuristic Manhattan-distance (newboard oldboard)
  (let* ((nexttile (1+ (board-completed-chain oldboard)))
	 (currentpos (current-position nexttile oldboard)))
    (unless (equal (position-contents currentpos newboard)	; If the tile hasn't changed position,
	       nexttile)			; don't calc the manhattan distance.
      (and 
	(> (man-dist nexttile currentpos (board-side oldboard))
	   (man-dist nexttile (current-position nexttile newboard)
		     (board-side oldboard)))	; The final = test checks to prohibit undoing
	(>= (completed-chain newboard) nexttile)))	; the existing complete chain.
    ))

(defun man-dist (place1 place2 side)
  (multiple-value-bind (div1 rem1)
      (floor (1- place1) side)
    (multiple-value-bind (div2 rem2)
	(floor (1- place2) side)
      (+ (abs (- div1 div2))
	 (abs (- rem1 rem2))))))

;;; Don't break up completed rows.  There is one exception - if the last completed row is
;;; the penultimate row, it may have to be broken in order to rotate the tiles in the last
;;; row.

(def-worse-heuristic completed-rows (newboard oldboard) 
  (unless (= (board-last-complete-row oldboard)
	     (1- (board-side oldboard)))
    (<= (row (board-blank newboard) newboard)
	(board-last-complete-row oldboard))))

;;; NEXT-TO-LAST-ROW is a weaker form of COMPLETED-ROWS.  It allows the penultimate row to
;;; be broken, but not the row before that.  The test in WHEN clause is only for efficiency
;;; - any other time that it succeeds, COMPLETED-ROWS would also succeed.

(def-worse-heuristic next-to-last-row (newboard oldboard)
  (when (= (board-last-complete-row oldboard)
	   (1- (board-side oldboard)))
    (< (row (board-blank newboard) newboard)
	(board-last-complete-row oldboard))))

;;; DONT-BREAK-CHAIN allows chains in partial rows to be rotated, but not to be broken up.
;;; Currently, it doesn't succeed as often as it might.   The definition of contiguous
;;; allows multiple paths through a blank square, so the position:
;;;       x      x      x      x
;;;       x      x      x      x
;;;       9   :blank   11      x
;;;       x     10      x      x
;;; still finds the 9-10-11 sequence contiguous.

(def-worse-heuristic dont-break-chain (newboard oldboard)
  (unless (zerop (board-completed-chain oldboard))	; No chain to break.
    (let* ((lefttile  (leftsquare (board-completed-chain oldboard) oldboard))
	   (righttile (board-completed-chain oldboard)))
      (loop for tilenumber from lefttile below righttile
	    when (not (contiguous tilenumber
				  (1+ tilenumber) newboard))
	      return t))))

;;; ACHIEVE-TWO-ROWS:    
;;;  IF
;;;    the blank is in neither the same row as the current end-of-chain 
;;;       nor the next row, AND
;;;    the next tile for the chain is in either of these rows, 
;;;  THEN
;;;    any move that moves the blank into a lower row (without backing up the current tile)
;;;    is an improvement.

(def-better-heuristic achieve-two-rows (newboard oldboard)
  (let* ((blankrow (row (board-blank oldboard) oldboard))
	 (endrow (row (board-completed-chain oldboard) oldboard))
	 (exceed2 (>= (- blankrow endrow) 2))
	 (tilerow (and exceed2			; Dont bother to compute tilerow if exceed2 fails.
		       (row (current-position (1+ (board-completed-chain oldboard))
					 oldboard) oldboard))))
    (when (and exceed2
	       (> blankrow tilerow))
      (and (< (row (board-blank newboard) newboard) blankrow)
	   (>= tilerow (row (current-position (1+ (board-completed-chain oldboard))
					 newboard) newboard))
	   (not (< (board-completed-chain newboard)(board-completed-chain oldboard)))
	   ))))

;;; IF 
;;;   the blank is already in the same row as the destination of the next tile in the chain, 
;;;     or the next row AND
;;;   the next tile for the chain is also in either of these rows
;;; THEN
;;;   any board which moves the blank more than one row beyond destination of the next tile is WORSE.

(def-worse-heuristic two-row-restriction (newboard oldboard)
  (let* ((blankrow (row (board-blank oldboard) oldboard))
	 (nextfillrow (row (1+ (board-completed-chain oldboard))
			   oldboard))
	 (exceed1 (> (- blankrow nextfillrow) 1))
	 (tilerow (and (not exceed1)			; Dont bother to compute tilerow if exceed1 fails.
		       (row (current-position (1+ (board-completed-chain oldboard))
					 oldboard) oldboard))))
   (when (and (not exceed1)
	      (<= tilerow (1+ nextfillrow)))
     (> (row (board-blank newboard) newboard)
	(1+ nextfillrow)))))